home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / program / 363 / xlisp20 / xlisp_c / xleval.c < prev    next >
Text File  |  1990-02-03  |  8KB  |  348 lines
  1. /* xleval - xlisp evaluator */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *xlstack,*xlenv;
  10. extern NODE *s_lambda,*s_macro;
  11. extern NODE *k_optional,*k_rest,*k_aux;
  12. extern NODE *s_evalhook,*s_applyhook;
  13. extern NODE *s_unbound;
  14. extern NODE *s_stdout;
  15.  
  16. /* forward declarations */
  17. FORWARD NODE *xlxeval();
  18. FORWARD NODE *evalhook();
  19. FORWARD NODE *evform();
  20. FORWARD NODE *evfun();
  21.  
  22. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  23. NODE *xleval(expr)
  24.   NODE *expr;
  25. {
  26.     return (getvalue(s_evalhook) ? evalhook(expr) : xlxeval(expr));
  27. }
  28.  
  29. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  30. NODE *xlxeval(expr)
  31.   NODE *expr;
  32. {
  33. #ifdef MEGAMAX
  34.     macidle();
  35. #endif
  36.  
  37.     /* evaluate nil to itself */
  38.     if (expr == NIL)
  39.     return (NIL);
  40.  
  41.     /* add trace entry */
  42.     xltpush(expr);
  43.  
  44.     /* check type of value */
  45.     if (consp(expr))
  46.     expr = evform(expr);
  47.     else if (symbolp(expr))
  48.     expr = xlgetvalue(expr);
  49.  
  50.     /* remove trace entry */
  51.     xltpop();
  52.  
  53.     /* return the value */
  54.     return (expr);
  55. }
  56.  
  57. /* xlapply - apply a function to a list of arguments */
  58. NODE *xlapply(fun,args)
  59.   NODE *fun,*args;
  60. {
  61.     NODE *env,*val;
  62.  
  63.     /* check for a null function */
  64.     if (fun == NIL)
  65.     xlfail("bad function");
  66.  
  67.     /* evaluate the function */
  68.     if (subrp(fun))
  69.     val = (*fun->n_subr)(args);
  70.     else if (consp(fun)) {
  71.     if (consp(car(fun))) {
  72.         env = cdr(fun);
  73.         fun = car(fun);
  74.     }
  75.     else
  76.         env = xlenv;
  77.     if (car(fun) != s_lambda)
  78.         xlfail("bad function type");
  79.     val = evfun(fun,args,env);
  80.     }
  81.     else
  82.     xlfail("bad function");
  83.  
  84.     /* return the result value */
  85.     return (val);
  86. }
  87.  
  88. /* evform - evaluate a form */
  89. LOCAL NODE *evform(expr)
  90.   NODE *expr;
  91. {
  92.     NODE *oldstk,fun,args,*env,*val,*type;
  93.  
  94.     /* create a stack frame */
  95.     oldstk = xlsave(&fun,&args,NULL);
  96.  
  97.     /* get the function and the argument list */
  98.     fun.n_ptr = car(expr);
  99.     args.n_ptr = cdr(expr);
  100.  
  101.     /* evaluate the first expression */
  102.     if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
  103.     xlfail("bad function");
  104.  
  105.     /* evaluate the function */
  106.     if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
  107.     if (subrp(fun.n_ptr))
  108.         args.n_ptr = xlevlist(args.n_ptr);
  109.     val = (*fun.n_ptr->n_subr)(args.n_ptr);
  110.     }
  111.     else if (consp(fun.n_ptr)) {
  112.     if (consp(car(fun.n_ptr))) {
  113.         env = cdr(fun.n_ptr);
  114.         fun.n_ptr = car(fun.n_ptr);
  115.     }
  116.     else
  117.         env = xlenv;
  118.     if ((type = car(fun.n_ptr)) == s_lambda) {
  119.         args.n_ptr = xlevlist(args.n_ptr);
  120.         val = evfun(fun.n_ptr,args.n_ptr,env);
  121.     }
  122.     else if (type == s_macro) {
  123.         args.n_ptr = evfun(fun.n_ptr,args.n_ptr,env);
  124.         val = xleval(args.n_ptr);
  125.     }
  126.     else
  127.         xlfail("bad function type");
  128.     }
  129.     else if (objectp(fun.n_ptr))
  130.     val = xlsend(fun.n_ptr,args.n_ptr);
  131.     else
  132.     xlfail("bad function");
  133.  
  134.     /* restore the previous stack frame */
  135.     xlstack = oldstk;
  136.  
  137.     /* return the result value */
  138.     return (val);
  139. }
  140.  
  141. /* evalhook - call the evalhook function */
  142. LOCAL NODE *evalhook(expr)
  143.   NODE *expr;
  144. {
  145.     NODE *oldstk,ehook,ahook,args,*val;
  146.  
  147.     /* create a new stack frame */
  148.     oldstk = xlsave(&ehook,&ahook,&args,NULL);
  149.  
  150.     /* make an argument list */
  151.     args.n_ptr = newnode(LIST);
  152.     rplaca(args.n_ptr,expr);
  153.     rplacd(args.n_ptr,newnode(LIST));
  154.     rplaca(cdr(args.n_ptr),xlenv);
  155.  
  156.     /* rebind the hook functions to nil */
  157.     ehook.n_ptr = getvalue(s_evalhook);
  158.     setvalue(s_evalhook,NIL);
  159.     ahook.n_ptr = getvalue(s_applyhook);
  160.     setvalue(s_applyhook,NIL);
  161.  
  162.     /* call the hook function */
  163.     val = xlapply(ehook.n_ptr,args.n_ptr);
  164.  
  165.     /* unbind the symbols */
  166.     setvalue(s_evalhook,ehook.n_ptr);
  167.     setvalue(s_applyhook,ahook.n_ptr);
  168.  
  169.     /* restore the previous stack frame */
  170.     xlstack = oldstk;
  171.  
  172.     /* return the value */
  173.     return (val);
  174. }
  175.  
  176. /* xlevlist - evaluate a list of arguments */
  177. NODE *xlevlist(args)
  178.   NODE *args;
  179. {
  180.     NODE *oldstk,src,dst,*new,*last,*val;
  181.  
  182.     /* create a stack frame */
  183.     oldstk = xlsave(&src,&dst,NULL);
  184.  
  185.     /* initialize */
  186.     src.n_ptr = args;
  187.  
  188.     /* evaluate each argument */
  189.     for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
  190.  
  191.     /* check this entry */
  192.     if (!consp(src.n_ptr))
  193.         xlfail("bad argument list");
  194.  
  195.     /* allocate a new list entry */
  196.     new = newnode(LIST);
  197.     if (val)
  198.         rplacd(last,new);
  199.     else
  200.         val = dst.n_ptr = new;
  201.     rplaca(new,xleval(car(src.n_ptr)));
  202.     last = new;
  203.     }
  204.  
  205.     /* restore the previous stack frame */
  206.     xlstack = oldstk;
  207.  
  208.     /* return the new list */
  209.     return (val);
  210. }
  211.  
  212. /* xlunbound - signal an unbound variable error */
  213. xlunbound(sym)
  214.   NODE *sym;
  215. {
  216.     xlcerror("try evaluating symbol again","unbound variable",sym);
  217. }
  218.  
  219. /* evfun - evaluate a function */
  220. LOCAL NODE *evfun(fun,args,env)
  221.   NODE *fun,*args,*env;
  222. {
  223.     NODE *oldstk,oldenv,newenv,cptr,*fargs,*val;
  224.  
  225.     /* create a stack frame */
  226.     oldstk = xlsave(&oldenv,&newenv,&cptr,NULL);
  227.  
  228.     /* skip the function type */
  229.     if ((fun = cdr(fun)) == NIL || !consp(fun))
  230.     xlfail("bad function definition");
  231.  
  232.     /* get the formal argument list */
  233.     if ((fargs = car(fun)) && !consp(fargs))
  234.     xlfail("bad formal argument list");
  235.  
  236.     /* create a new environment frame */
  237.     newenv.n_ptr = xlframe(env);
  238.     oldenv.n_ptr = xlenv;
  239.  
  240.     /* bind the formal parameters */
  241.     xlabind(fargs,args,newenv.n_ptr);
  242.     xlenv = newenv.n_ptr;
  243.  
  244.     /* execute the code */
  245.     for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
  246.     val = xlevarg(&cptr.n_ptr);
  247.  
  248.     /* restore the environment */
  249.     xlenv = oldenv.n_ptr;
  250.  
  251.     /* restore the previous stack frame */
  252.     xlstack = oldstk;
  253.  
  254.     /* return the result value */
  255.     return (val);
  256. }
  257.  
  258. /* xlabind - bind the arguments for a function */
  259. xlabind(fargs,aargs,env)
  260.   NODE *fargs,*aargs,*env;
  261. {
  262.     NODE *arg;
  263.  
  264.     /* evaluate and bind each required argument */
  265.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  266.  
  267.     /* bind the formal variable to the argument value */
  268.     xlbind(arg,car(aargs),env);
  269.  
  270.     /* move the argument list pointers ahead */
  271.     fargs = cdr(fargs);
  272.     aargs = cdr(aargs);
  273.     }
  274.  
  275.     /* check for the '&optional' keyword */
  276.     if (consp(fargs) && car(fargs) == k_optional) {
  277.     fargs = cdr(fargs);
  278.  
  279.     /* bind the arguments that were supplied */
  280.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  281.  
  282.         /* bind the formal variable to the argument value */
  283.         xlbind(arg,car(aargs),env);
  284.  
  285.         /* move the argument list pointers ahead */
  286.         fargs = cdr(fargs);
  287.         aargs = cdr(aargs);
  288.     }
  289.  
  290.     /* bind the rest to nil */
  291.     while (consp(fargs) && !iskeyword(arg = car(fargs))) {
  292.  
  293.         /* bind the formal variable to nil */
  294.         xlbind(arg,NIL,env);
  295.  
  296.         /* move the argument list pointer ahead */
  297.         fargs = cdr(fargs);
  298.     }
  299.     }
  300.  
  301.     /* check for the '&rest' keyword */
  302.     if (consp(fargs) && car(fargs) == k_rest) {
  303.     fargs = cdr(fargs);
  304.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  305.         xlbind(arg,aargs,env);
  306.     else
  307.         xlfail("symbol missing after &rest");
  308.     fargs = cdr(fargs);
  309.     aargs = NIL;
  310.     }
  311.  
  312.     /* check for the '&aux' keyword */
  313.     if (consp(fargs) && car(fargs) == k_aux)
  314.     while ((fargs = cdr(fargs)) != NIL && consp(fargs))
  315.         xlbind(car(fargs),NIL,env);
  316.  
  317.     /* make sure the correct number of arguments were supplied */
  318.     if (fargs != aargs)
  319.     xlfail(fargs ? "too few arguments" : "too many arguments");
  320. }
  321.  
  322. /* iskeyword - check to see if a symbol is a keyword */
  323. LOCAL int iskeyword(sym)
  324.   NODE *sym;
  325. {
  326.     return (sym == k_optional || sym == k_rest || sym == k_aux);
  327. }
  328.  
  329. /* xlsave - save nodes on the stack */
  330. NODE *xlsave(n)
  331.   NODE *n;
  332. {
  333.     NODE **nptr,*oldstk;
  334.  
  335.     /* save the old stack pointer */
  336.     oldstk = xlstack;
  337.  
  338.     /* save each node */
  339.     for (nptr = &n; *nptr != NULL; nptr++) {
  340.     rplaca(*nptr,NIL);
  341.     rplacd(*nptr,xlstack);
  342.     xlstack = *nptr;
  343.     }
  344.  
  345.     /* return the old stack pointer */
  346.     return (oldstk);
  347. }
  348. əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə